home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl5 / Mail / Cap.pm < prev    next >
Encoding:
Perl POD Document  |  2008-04-14  |  6.0 KB  |  241 lines
  1. # Copyrights 1995-2008 by Mark Overmeer <perl@overmeer.net>.
  2. #  For other contributors see ChangeLog.
  3. # See the manual pages for details on the licensing terms.
  4. # Pod stripped from pm file by OODoc 1.04.
  5. package Mail::Cap;
  6. use vars '$VERSION';
  7. $VERSION = '2.03';
  8. use strict;
  9.  
  10. sub Version { our $VERSION }
  11.  
  12.  
  13. our $useCache = 1;  # don't evaluate tests every time
  14.  
  15. my @path;
  16. if($^O eq "MacOS")
  17. {   @path = split /\,/, $ENV{MAILCAPS} || "$ENV{HOME}mailcap";
  18. }
  19. else
  20. {   @path = split /\:/
  21.       , ( $ENV{MAILCAPS} || (defined $ENV{HOME} ? "$ENV{HOME}/.mailcap:" : '')
  22.         . '/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap'
  23.         );   # this path is specified under RFC1524 appendix A 
  24. }
  25.  
  26.  
  27. sub new
  28. {   my $class = shift;
  29.     
  30.     unshift @_, 'filename' if @_ % 2;
  31.     my %args  = @_;
  32.  
  33.     my $take_all = $args{take} && uc $args{take} eq 'ALL';
  34.  
  35.     my $self  = bless {_count => 0}, $class;
  36.  
  37.     $self->_process_file($args{filename})
  38.         if defined $args{filename} && -r $args{filename};
  39.  
  40.     if(!defined $args{filename} || $take_all)
  41.     {   foreach my $fname (@path)
  42.         {   -r $fname or next;
  43.  
  44.             $self->_process_file($fname);
  45.             last unless $take_all;
  46.         }
  47.     }
  48.  
  49.     unless($self->{_count})
  50.     {   # Set up default mailcap
  51.         $self->{'audio/*'} = [{'view' => "showaudio %s"}];
  52.         $self->{'image/*'} = [{'view' => "xv %s"}];
  53.         $self->{'message/rfc822'} = [{'view' => "xterm -e metamail %s"}];
  54.     }
  55.  
  56.     $self;
  57. }
  58.  
  59. sub _process_file
  60. {   my $self = shift;
  61.     my $file = shift or return;
  62.  
  63.     local *MAILCAP;
  64.     open MAILCAP, $file
  65.         or return;
  66.  
  67.     $self->{_file} = $file;
  68.  
  69.     local $_;
  70.     while(<MAILCAP>)
  71.     {   next if /^\s*#/; # comment
  72.         next if /^\s*$/; # blank line
  73.         $_ .= <MAILCAP> while s/\\\s*$//; # continuation line
  74.         chomp;
  75.         s/\0//g;            # ensure no NULs in the line
  76.         s/([^\\]);/$1\0/g;  # make field separator NUL
  77.  
  78.         my @parts = split /\s*\0\s*/, $_;
  79.         my $type  = shift @parts;
  80.         $type    .= "/*" if $type !~ m[/];
  81.  
  82.         my $view  = shift @parts;
  83.         $view     =~ s/\\;/;/g;
  84.         my %field = (view => $view);
  85.  
  86.         foreach (@parts)
  87.         {   my($key, $val) = split /\s*\=\s*/, $_, 2;
  88.             $val =~ s/\\;/;/g if defined $val;
  89.             $field{$key} = defined $val ? $val : 1;
  90.         }
  91.  
  92.         if(my $test = $field{test})
  93.         {   unless ($test =~ /\%/)
  94.             {   # No parameters in test, can perform it right away
  95.                 system $test;
  96.                 next if $?;
  97.             }
  98.         }
  99.  
  100.         # record this entry
  101.         unless(exists $self->{$type})
  102.         {   $self->{$type} = [];
  103.             $self->{_count}++; 
  104.         }
  105.         push @{$self->{$type}}, \%field;
  106.     }
  107.  
  108.     close MAILCAP;
  109. }
  110.  
  111.  
  112. sub view    { my $self = shift; $self->_run($self->viewCmd(@_))    }
  113. sub compose { my $self = shift; $self->_run($self->composeCmd(@_)) }
  114. sub edit    { my $self = shift; $self->_run($self->editCmd(@_))    }
  115. sub print   { my $self = shift; $self->_run($self->printCmd(@_))   }
  116.  
  117. sub _run($)
  118. {   my ($self, $cmd) = @_;
  119.     defined $cmd or return 0;
  120.  
  121.     system $cmd;
  122.     1;
  123. }
  124.  
  125.  
  126. sub viewCmd    { shift->_createCommand(view    => @_) }
  127. sub composeCmd { shift->_createCommand(compose => @_) }
  128. sub editCmd    { shift->_createCommand(edit    => @_) }
  129. sub printCmd   { shift->_createCommand(print   => @_) }
  130.  
  131. sub _createCommand($$$)
  132. {   my ($self, $method, $type, $file) = @_;
  133.     my $entry = $self->getEntry($type, $file);
  134.  
  135.     $entry && exists $entry->{$method}
  136.         or return undef;
  137.  
  138.     $self->expandPercentMacros($entry->{$method}, $type, $file);
  139. }
  140.  
  141. sub makeName($$)
  142. {   my ($self, $type, $basename) = @_;
  143.     my $template = $self->nametemplate($type)
  144.         or return $basename;
  145.  
  146.     $template =~ s/%s/$basename/g;
  147.     $template;
  148. }
  149.  
  150.  
  151. sub field($$)
  152. {   my($self, $type, $field) = @_;
  153.     my $entry = $self->getEntry($type);
  154.     $entry->{$field};
  155. }
  156.  
  157.  
  158. sub description     { shift->field(shift, 'description');     }
  159. sub textualnewlines { shift->field(shift, 'textualnewlines'); }
  160. sub x11_bitmap      { shift->field(shift, 'x11-bitmap');      }
  161. sub nametemplate    { shift->field(shift, 'nametemplate');    }
  162.  
  163. sub getEntry
  164. {   my($self, $origtype, $file) = @_;
  165.  
  166.     return $self->{_cache}{$origtype}
  167.         if $useCache && exists $self->{_cache}{$origtype};
  168.  
  169.     my ($fulltype, @params) = split /\s*;\s*/, $origtype;
  170.     my ($type, $subtype)    = split m[/], $fulltype, 2;
  171.     $subtype ||= '';
  172.  
  173.     my $entry;
  174.     foreach (@{$self->{"$type/$subtype"}}, @{$self->{"$type/*"}})
  175.     {   if(exists $_->{'test'})
  176.         {   # must run test to see if it applies
  177.             my $test = $self->expandPercentMacros($_->{'test'},
  178.                               $origtype, $file);
  179.             system $test;
  180.             next if $?;
  181.         }
  182.         $entry = { %$_ };  # make copy
  183.         last;
  184.     }
  185.     $self->{_cache}{$origtype} = $entry if $useCache;
  186.     $entry;
  187. }
  188.  
  189. sub expandPercentMacros
  190. {   my ($self, $text, $type, $file) = @_;
  191.     defined $type or return $text;
  192.     defined $file or $file = "";
  193.  
  194.     my ($fulltype, @params) = split /\s*;\s*/, $type;
  195.     ($type, my $subtype)    = split m[/], $fulltype, 2;
  196.  
  197.     my %params;
  198.     foreach (@params)
  199.     {   my($key, $val) = split /\s*=\s*/, $_, 2;
  200.         $params{$key} = $val;
  201.     }
  202.     $text =~ s/\\%/\0/g;        # hide all escaped %'s
  203.     $text =~ s/%t/$fulltype/g;  # expand %t
  204.     $text =~ s/%s/$file/g;      # expand %s
  205.     {   # expand %{field}
  206.         local $^W = 0;  # avoid warnings when expanding %params
  207.         $text =~ s/%\{\s*(.*?)\s*\}/$params{$1}/g;
  208.     }
  209.     $text =~ s/\0/%/g;
  210.     $text;
  211. }
  212.  
  213. # This following procedures can be useful for debugging purposes
  214.  
  215. sub dumpEntry
  216. {   my($hash, $prefix) = @_;
  217.     defined $prefix or $prefix = "";
  218.     print "$prefix$_ = $hash->{$_}\n"
  219.         for sort keys %$hash;
  220. }
  221.  
  222. sub dump
  223. {   my $self = shift;
  224.     foreach (keys %$self)
  225.     {   next if /^_/;
  226.         print "$_\n";
  227.         foreach (@{$self->{$_}})
  228.         {   dumpEntry($_, "\t");
  229.             print "\n";
  230.         }
  231.     }
  232.  
  233.     if(exists $self->{_cache})
  234.     {   print "Cached types\n";
  235.         print "\t$_\n"
  236.             for keys %{$self->{_cache}};
  237.     }
  238. }
  239.  
  240. 1;
  241.